home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1996 September / Software of the Month Club 1996 September.iso / mac / Software Research Institute-SRI / Business / Alpha ƒ / Tcl / SystemCode / modes.tcl < prev    next >
Encoding:
Text File  |  1996-01-05  |  14.9 KB  |  667 lines  |  [TEXT/ALFA]
  1. # New modes can be specified by appending to the following vars.
  2. # are no longer any procs such as 'setTextMode' etc.
  3.  
  4. # 'mode' is nothing when we start up.
  5. set mode ""
  6.  
  7.  
  8. #================================================================================
  9. # The next two procs are called by Alpha to handle the mode flags popup menu.
  10. #================================================================================
  11.  
  12. proc getModeValuesAlpha {} {
  13.  
  14.     getWinInfo blah
  15.     lappend m "Mac" [expr {$blah(platform) == "mac"}]
  16.     lappend m "UNIX" [expr {$blah(platform) == "unix"}]
  17.     lappend m "IBM" [expr {$blah(platform) == "ibm"}] {(-} 0
  18.     lappend m "MPW" [expr {$blah(state) == "mpw"}]
  19.     lappend m "Think" [expr {$blah(state) == "think"}]
  20.     lappend m "None" [expr {$blah(state) == "none"}] {(-} 0
  21.     lappend m "Read Only" $blah(read-only) {(-} 0
  22.     lappend m "Tab Size" 0
  23.     return $m
  24. }
  25.  
  26.  
  27. proc setModeVarAlpha {var} {
  28.     global mode allFlags modeVars modifiedModeVars
  29.     global ${mode}modeVars
  30.     
  31.     set var [string tolower $var]
  32.     switch $var {
  33.         "unix"        -
  34.         "mac"        -
  35.         "ibm"        { setWinInfo platform $var }
  36.         "mpw"        -
  37.         "think"        -
  38.         "none"        { setWinInfo state $var }
  39.         "tab size"  {
  40.             getWinInfo arr
  41.             if {![catch {prompt "New tab size?" $arr(tabsize)} res]} {
  42.                 setWinInfo tabsize $res
  43.             }
  44.         }
  45.         "read only"    { 
  46.             getWinInfo b
  47.             setWinInfo read-only [expr -1 * ($b(read-only) - 1)]}
  48.     }
  49.     return
  50. }
  51.             
  52. proc createModeMenu {} {
  53.     global mode
  54.     global ${mode}modeVars
  55.     global allFlags
  56.     set fvals {}
  57.     set vvals {}
  58.     set flagsOn {}
  59.  
  60.     if {[info exists ${mode}modeVars]} {
  61.         set vars [lsort [array names ${mode}modeVars]]
  62.         foreach v $vars {
  63.             if {[lsearch $allFlags $v] >= 0} {
  64.                 if "[set ${mode}modeVars($v)]" {
  65.                     lappend flagsOn $v
  66.                 }
  67.                 lappend fvals $v
  68.             } else {
  69.                 lappend vvals $v
  70.             }
  71.         }
  72.     }
  73.     menu -m -n mode -p modeMenuProc [concat $fvals {(-} $vvals {(-} {"Set Mode Menus╔" "Change Mode Vars╔" "Describe Mode" }]
  74.     foreach v $flagsOn {
  75.         markMenuItem mode $v on
  76.     }
  77. }
  78.  
  79.  
  80. proc modeMenuProc {menu var} {
  81.     global mode modeVars allFlags
  82.     global ${mode}modeVars
  83.     if {$var == "Set Mode Menus"} {
  84.         setModeMenus
  85.     } elseif {$var == "Change Mode Vars"} {
  86.         set mvars {}
  87.         catch {set mvars [array names ${mode}modeVars]}
  88.         set vars [listpick -l -L $mvars -p "Set mode vars for '$mode':" [lsort $modeVars]]
  89.         if {![string length $vars]} return
  90.         
  91.         catch {unset ${mode}modeVars}
  92.         foreach v $vars {
  93.             global $v
  94.             set ${mode}modeVars($v) [set $v]
  95.         }
  96.     } elseif {$var == "Describe Mode"} {
  97.         describeMode
  98.     } elseif {[lsearch $allFlags $var] >= 0} {
  99.         global $var
  100.         set ${mode}modeVars($var) [set $var [expr -1 * ([set ${mode}modeVars($var)] - 1)]]
  101.         lappend modifiedModeVars [list $var ${mode}modeVars]
  102.         createModeMenu
  103.     } else {
  104.         global $var
  105.         set res [prompt "New value of '$var':" [set ${mode}modeVars($var)]]
  106.         set ${mode}modeVars($var) $res
  107.         set $var $res
  108.         lappend modifiedModeVars [list $var ${mode}modeVars]
  109.         createModeMenu
  110.     }
  111. }
  112.  
  113. #================================================================================
  114.  
  115.  
  116. # Suffixes used to initially determine mode for new window.
  117. set modeSuffixes { default { set winMode Text } }
  118.  
  119.  
  120. # The set of menus that the modes may choose to use.
  121. set allModeMenus {     thinkMenu cwarriorMenu toolserverMenu
  122.                     latexMenu thinkRefMenu toolboxRefMenu tclMenu perlMenu }
  123.  
  124. set modeVars { }
  125.  
  126.  
  127. # The dummy proc for a mode is called whenever we change to that mode,
  128. # so that the autoloading facility will load the correct file, if
  129. # necessary.
  130.  
  131. # The list of modes.
  132. set modes         {}
  133. set lastMode     0
  134.  
  135. # Can be used to add new mode-specific flags and variables (see think.tcl for example).
  136. proc newModeVar {mode var val isFlag} {
  137.     global ${mode}modeVars modeVars allFlags $var
  138.     
  139.     if {![info exists modeVars] || [lsearch $modeVars $var] < 0} {
  140.         lappend modeVars $var
  141.     }
  142.     if {![info exists ${mode}modeVars($var)]} {
  143.         set ${mode}modeVars($var) $val
  144.         if {![info exists $var]} {
  145.             set $var $val
  146.         }
  147.     }
  148.     if {$isFlag && (![info exists allFlags] || ([lsearch $allFlags $var] < 0))} {
  149.         lappend allFlags $var
  150.     }
  151. }
  152.  
  153. #================================================================================
  154. if {!$alphaLite} {
  155.     source "$HOME:Tcl:SystemCode:modeDefs.tcl"
  156. }
  157.  
  158. #================================================================================
  159.  
  160. proc buildFlagsVars {} {
  161.     global allFlags allVars modeVars
  162.     
  163.     set fs {}
  164.     foreach f [lsort $allFlags] {
  165.         if {[lsearch $modeVars $f] < 0} {
  166. #             lappend fs "<E<S? $f"
  167. #             lappend fs "<S$f"
  168.               lappend flags $f
  169.         }
  170.     }
  171.     menu -m -n flags -p editFlag $flags
  172.     eval global $flags
  173.     foreach f $flags {
  174.         markMenuItem flags $f [set $f]
  175.     }
  176.  
  177.     set fs {}
  178.     set flags {}
  179.     foreach f [lsort $allVars] {
  180.         if {[lsearch $modeVars $f] < 0} {
  181. #             lappend fs "<E<S? $f"
  182. #             lappend fs "<S$f"
  183.             lappend fs "$f"
  184.         }
  185.     }
  186.     menu -m -n vars -p editVar $fs
  187. }
  188.  
  189.  
  190. proc saveVarValues {} {
  191.     global modes HOME
  192.     if {[askyesno "Save variables and values to \"$HOME:alphaFlags.tcl\"?"] == "yes"} {
  193.         set lines {}
  194.         foreach m $modes {
  195.             global ${m}modeVars
  196.             
  197.             if {[info exists ${m}modeVars]} {
  198.                 foreach v [array names ${m}modeVars] {
  199.                     append lines "set ${m}modeVars($v)\t\t\{[set ${m}modeVars($v)]\}\r"
  200.                 }
  201.                 append lines "\r"
  202.             }
  203.         }
  204.         
  205.         append lines "\r\r"
  206.         global allFlags allVars
  207.         set vars [lsort [concat $allFlags $allVars]]
  208.         eval global $vars
  209.         foreach f $vars {
  210.             append lines "set $f\t\t\{[set $f]\}\r"
  211.         }
  212.  
  213.         set fd [open "$HOME:alphaFlags.tcl" "w"]
  214.         puts $fd $lines
  215.         close $fd
  216.         message "New '$HOME:alphaFlags.tcl' written."
  217.     }
  218. }
  219.  
  220.  
  221. #================================================================================
  222.  
  223. proc setWinMode name {
  224.     global winModes modeSuffixes
  225.     set nm [file tail $name]
  226.     if {[set first [string last " <" $nm]] >= 0} {
  227.         set rname [string range $nm 0 [expr $first - 1]]
  228.     } else {
  229.         set rname $nm
  230.     }
  231.     case $rname in $modeSuffixes
  232.     set winModes($name) $winMode
  233. }
  234.  
  235.  
  236.  
  237. proc newMode mode {
  238.     global winModes modeProcs
  239.     
  240.     set name [lindex [winNames -f] 0]
  241.     changeMode $mode
  242.     set winModes($name) $mode
  243.     centerRedraw
  244. }
  245.  
  246.  
  247. proc deactivateHook name {
  248. }
  249.  
  250. proc suspendHook name {
  251.     global iconifyOnSwitch
  252.     global suspIconed
  253.     if {$iconifyOnSwitch} {
  254.         set wins [winNames -f]
  255.         set suspIconed ""
  256.         foreach win $wins {
  257.             if {![icon -f "$win" -q]} {
  258.                 lappend suspIconed $win
  259.                 icon -f "$win" -t
  260.             }
  261.         }
  262.         set suspIconed [lreverse $suspIconed]
  263.     }
  264. }
  265.  
  266.  
  267. set killCompilerErrors 0
  268.  
  269. proc resumeHook name {
  270.     global iconifyOnSwitch resumeRevert suspIconed killCompilerErrors
  271.  
  272.     if {$killCompilerErrors} {
  273.         set wins [winNames -f]
  274.         if {[set res [lsearch $wins "*Compiler Errors*"]] >= 0} {
  275.             bringToFront [lindex $wins $res]
  276.             killWindow
  277.         }
  278.     }
  279.     
  280.     if {$iconifyOnSwitch && [info exists suspIconed]} {
  281.         set wins [winNames -f]
  282.         foreach win $suspIconed {
  283.             icon -f "$win" -o
  284.         }
  285.         unset suspIconed
  286.     }
  287.     if {$resumeRevert} {
  288.         set resumeRevert 0
  289.         revert
  290.     }
  291. }
  292.  
  293.  
  294.  
  295. # Handles dynamically adding and deleting window names from menu.
  296. proc addWinName name {
  297.     global winNameToNum winMenu winNumToName
  298.     
  299.     for {set i 0} {$i<100} {incr i} {
  300.         if {[catch {set nm $winNumToName($i)} res] == "1"} {
  301.             regexp {[^:]*$} $name nm
  302.             if {$i < 10} {
  303.                 addMenuItem -m -l "/$i" $winMenu $nm
  304.             } else {
  305.                 addMenuItem -m -l "" $winMenu $nm
  306.             }
  307.             set winNumToName($i) $name
  308.             set winNameToNum($name) $i
  309.             return
  310.         }
  311.     }
  312. }
  313.  
  314. proc removeWinName name {
  315.     global winNameToNum winNumToName winMenu
  316.     
  317.     set num $winNameToNum($name)
  318.     unset winNumToName($num)
  319.     unset winNameToNum($name)
  320.     regexp {[^:]*$} $name nm
  321.     deleteMenuItem -m $winMenu $nm
  322. }
  323.  
  324.  
  325. proc menuWin {menu name} {
  326.     global winNameToNum
  327.  
  328.     set nms [array names winNameToNum]
  329.  
  330.     if {[lsearch $nms "*$name"] < 0} {
  331.         $name
  332.         return
  333.     }
  334.  
  335.     foreach nm $nms {
  336.         if {[string match *$name $nm] == "1"}  {
  337.             bringToFront $name
  338.             if [icon -q] { icon -f $name -o }
  339.             return
  340.         }
  341.     }
  342.     return "normal"
  343. }
  344.  
  345.  
  346. # Do not move 'displayMode' calls!
  347. proc changeMode {newMode} {
  348.     global lastMode modeMenus dummyProc mode seenMode PREFS
  349.     
  350.     set lastMode $mode
  351.     set mode $newMode
  352.     if {$lastMode == $mode} {
  353.         catch {displayMode $newMode}
  354.         return
  355.     }
  356.  
  357.     # Used to be after the modeVar stuff. Why?
  358.     if {[info exists dummyProc($mode)]} { $dummyProc($mode) }
  359.  
  360.     global ${mode}modeVars
  361.     if {[info exists ${mode}modeVars]} {
  362.         foreach v [array names ${mode}modeVars] {
  363.             global $v
  364.             set $v [set ${mode}modeVars($v)]
  365.         }
  366.     }
  367.  
  368.     if {[info exists modeMenus($lastMode)]} {
  369.         foreach m $modeMenus($lastMode) {
  370.             global $m
  371.             catch {removeMenu [set $m]}
  372.         }
  373.     }
  374.     if {[info exists modeMenus($mode)]} {
  375.         foreach m $modeMenus($mode) {
  376.             catch {$m}
  377.             global $m
  378.             catch {insertMenu [set $m]}
  379.         }
  380.     }
  381.     
  382.     if {![info exists seenMode($mode)]} {
  383.         if {[file exists "$PREFS:${mode}Prefs.tcl"]} {
  384.             source "$PREFS:${mode}Prefs.tcl"
  385.         }
  386.         set seenMode($mode) 1
  387.     }
  388.         
  389.     catch {displayMode $newMode}
  390.  
  391.     createModeMenu
  392. }
  393.  
  394.  
  395. proc setModeMenus {} {
  396.     global mode modeMenus allModeMenus modifiedModeMenus
  397.  
  398.     set menus [listpick -p "Pick menus for mode '$mode':" -l -L $modeMenus($mode) [lsort $allModeMenus]]
  399.     set modeMenus($mode) $menus
  400.  
  401.     lappend modifiedModeMenus $mode
  402.  
  403.     foreach m $allModeMenus {
  404.         global $m
  405.         catch {removeMenu [set $m]}
  406.     }
  407.     foreach m $menus {
  408.         global $m
  409.         catch {$m}
  410.         catch {insertMenu [set $m]}
  411.     }
  412. }
  413.  
  414.  
  415. #=============================================================================
  416. # Hook procs recognized: "openHook", "closeHook", "activateHook", "deactivateHook", 
  417. #                          "suspendHook", "saveasHook", "saveHook", and "resumeHook".
  418. #=============================================================================
  419.  
  420. if {![info exists winActive]} {set winActive ""}
  421.  
  422. # Event hooks - set specific modes when files opened.
  423.  
  424.  
  425. proc openHook name {
  426.     global winModes winActive autoMark mode screenHeight screenWidth forceMainScreen recentFiles recentFilesCount
  427.     changeMode $winModes($name)
  428.     if {$name == {*Toolserver shell*}} startMPW
  429.     addWinName $name
  430.     message ""
  431.  
  432.     if {![catch {getFileInfo $name info}]} {
  433.         if {$info(creator) == {ttxt}} {
  434.             setWinInfo dirty 0
  435.         }
  436.         if {$info(type) == {ttro}} {
  437.             catch {setWinInfo read-only 1}
  438.             message "Read-only!"
  439.         }
  440.     }
  441.  
  442.     global ${mode}modeVars
  443.     
  444.     if {$forceMainScreen} {
  445.         set geo [getGeometry]
  446.         set l [lindex $geo 0]; set t [lindex $geo 1]; set w [lindex $geo 2]; set h [lindex $geo 3]; 
  447.         if {($l < 0) || ($t < 35) || ([expr $l + $w] > $screenWidth) || ([expr $t + $h + 18] > $screenHeight)} {
  448.             singlePage
  449.         }
  450.     }
  451.     getWinInfo arr
  452.     if {[info exists ${mode}modeVars(autoMark)] && [set ${mode}modeVars(autoMark)] && !$arr(read-only) && ![llength [getNamedMarks -n]]} {
  453.         markFile
  454.     }
  455.     
  456.     if {[string match "*Preferences*defs.tcl" $name]} {setWinInfo read-only 1}
  457.     
  458.     pushRecent $name 
  459. }
  460.  
  461.  
  462. # full pathname
  463. proc saveHook name {
  464.     global backup backExtension backDir mode
  465.     
  466.     if {($mode == "C") || ($mode == "C++")} {catch {modified}}
  467.  
  468.     if ($backup) {
  469.         if {![string length [set dir $backDir]]} {
  470.             set dir [file dirname $name]
  471.         }
  472.         if {![file exists $dir]} {
  473.             if {[askyesno "Create backup dir '$dir'?"] == "yes"} {
  474.                 mkdir $dir
  475.             }
  476.         }
  477.         catch {rm $dir:[file tail $name]$backExtension}
  478.         catch {cp $name $dir:[file tail $name]$backExtension}
  479.     }
  480. }
  481.  
  482. # Clean up the mark stack.
  483. proc closeHook name {
  484.     global markStack winModes winActive
  485.  
  486.     unset winModes($name)
  487.     if [llength $markStack] {
  488.         set markStack [removePat $markStack $name*]
  489.     }
  490.     removeWinName $name
  491.  
  492.     if {[set ind [lsearch $winActive $name]] >= 0} {
  493.         set winActive [lreplace $winActive $ind $ind]
  494.     }
  495.  
  496.     catch {unset winModes($name)}
  497. }
  498.  
  499.  
  500. proc saveasHook {oldName newName} {
  501.     global winModes winActive
  502.     removeWinName $oldName
  503.     addWinName $newName
  504.     setWinMode $newName
  505.     changeMode $winModes($newName)
  506.     
  507.     pushRecent $newName
  508.     
  509.     if {[set ind [lsearch $winActive $oldName]] >= 0} {
  510.         set winActive [lreplace $winActive $ind $ind]
  511.     }
  512.     set winActive [linsert $winActive 0 $newName]
  513.     catch {unset winModes($oldName)}
  514. }
  515.  
  516. if {![info exists actives]} {set actives 0}
  517.  
  518. # and, install a new 'winActive' patch , to 'activateHook':
  519.  
  520. proc activateHook name {
  521.     global winModes winActive
  522.     if {![info exists winModes($name)]} {
  523.         setWinMode $name
  524.     }
  525.     changeMode $winModes($name)
  526.  
  527.     if {[set ind [lsearch $winActive $name]] == -1} {
  528.         set winActive [linsert $winActive 0 $name]
  529.         return
  530.     }
  531.     if {$ind >= 1} {
  532.         set winActive [lreplace $winActive $ind $ind]
  533.         set winActive [linsert $winActive 0 $name]
  534.     }
  535.  
  536. }
  537.  
  538.  
  539. proc dirtyHook {name dirty} {
  540.     global winMenu
  541.     markMenuItem $winMenu [file tail $name] $dirty "╫"
  542. }
  543.  
  544.  
  545. set modifiedVars        {}
  546. set modifiedArrVars        {}
  547. set modifiedModeVars    {}
  548. set modifiedModeMenus    {}
  549.  
  550.  
  551. proc quitHook {} {
  552.     global quitHooks
  553.     saveModifiedVars
  554.     if {[info exists quitHooks]} {
  555.         foreach item $quitHooks {
  556.             $item
  557.         }
  558.     }
  559. }
  560.  
  561.  
  562. proc saveModifiedVars {} {
  563.     global modifiedVars modifiedModeVars modifiedArrVars modifiedModeMenus modeMenus prefDefs recentFilesSave recentFiles
  564.  
  565.     if {[llength $modifiedVars] || [llength $modifiedArrVars] || [llength $modifiedModeVars] || [llength $modifiedModeMenus]} {
  566.         foreach f [removeDups $modifiedModeMenus] {
  567.             addArrDef modeMenus $f $modeMenus($f)
  568.         }
  569.         foreach f [removeDups $modifiedArrVars] {
  570.             global $f
  571.             foreach ind [array names $f] {
  572.                 addArrDef $f $ind [set ${f}($ind)]
  573.             }
  574.         }
  575.         foreach f [removeDups $modifiedVars] {
  576.             global $f
  577.             addDef $f [set $f]
  578.         }
  579.         foreach f [removeDups $modifiedModeVars] {
  580.             set nm [lindex $f 0]
  581.             set mode [lindex $f 1]
  582.             global $mode
  583.             addArrDef [set mode] $nm [set [set mode]($nm)]
  584.         }
  585.     }
  586.     
  587.     if {[info exists recentFiles]} {
  588.         addDef recentFilesSave $recentFiles
  589.     }
  590. }
  591.  
  592. #================================================================================
  593.  
  594. proc describeMode {} {
  595.     global mode modeSuffixes modeMenus modes
  596.     global ${mode}modeVars
  597.     
  598.     set text "\r\tMODE $mode\r\r"
  599.     set suffs ""
  600.     set first 1
  601.     foreach suf $modeSuffixes {
  602.         if {([llength $suf] == 3) && ([lindex $suf 1] == "winMode") && ([lindex $suf 2] == $mode)} {
  603.             if {$first} {
  604.                 lappend suffs $last
  605.                 set first 0
  606.             } else {
  607.                 append suffs ", $last"
  608.             }
  609.         }
  610.         set last $suf
  611.     }
  612.     append text "Mode suffixes: $suffs\r\r"
  613.     
  614.     set first 1
  615.     append text "Mode menus: "
  616.     if {[info exists modeMenus($mode)]} {
  617.         foreach m $modeMenus($mode) {
  618.             if $first {
  619.                 set first 0
  620.                 lappend text $m
  621.             } else {
  622.                 append text ", $m"
  623.             }
  624.         }
  625.     }
  626.     append text "\r\r"
  627.  
  628.     append text "Mode-specific variables:\r"
  629.     if {[info exists ${mode}modeVars]} {
  630.         foreach v [lsort [array names ${mode}modeVars]] {
  631.             append text [format "\t%-20s: \"%s\"\r" $v [set ${mode}modeVars($v)]]
  632.         }
  633.     }
  634.  
  635.  
  636.     set etext "\rMode-independent bindings:\r"
  637.     append text "\rMode-specific bindings:\r"
  638.     foreach b [split [bindingList] "\r"] {
  639.         set lst [lindex $b end]
  640.         if {$lst == $mode} {
  641.             append text "\t$b\r"
  642.         } elseif {[lsearch $modes $lst] < 0} {
  643.             append etext "\t$b\r"
  644.         }
  645.     }
  646.     new -n "* <$mode> MODE *"
  647.     insertText $text$etext
  648.     goto 0
  649.     
  650.     setWinInfo dirty 0
  651. }
  652.  
  653.  
  654. #================================================================================
  655. lappend modes Text
  656. set modeMenus(Text)                { }
  657. newModeVar Text leftFillColumn {0} 0
  658. newModeVar Text suffixString { <--} 0
  659. newModeVar Text prefixString {> } 0
  660. newModeVar Text fillColumn {75} 0
  661. newModeVar Text wordWrap {1} 1
  662. newModeVar Text wordBreak {[a-zA-Z0-9_]+} 0
  663. newModeVar Text wordBreakPreface {([^a-zA-Z0-9_])} 0
  664. newModeVar Text wrapBreak {[a-zA-Z0-9_]+} 0
  665. newModeVar Text wrapBreakPreface {([^a-zA-Z0-9_])} 0
  666. newModeVar Text autoMark    0    1
  667.